home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / dblookup.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  42.5 KB  |  1,535 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit DBLookup;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses Windows, Classes, StdCtrls, DB, Controls, Messages, SysUtils,
  17.   Forms, Graphics, Menus, Buttons, DBGrids, DBTables, Grids, DBCtrls;
  18.  
  19. type
  20.  
  21. { TDBLookupCombo }
  22.  
  23.   TPopupGrid = class;
  24.  
  25.   TDBLookupComboStyle = (csDropDown, csDropDownList);
  26.   TDBLookupListOption = (loColLines, loRowLines, loTitles);
  27.   TDBLookupListOptions = set of TDBLookupListOption;
  28.  
  29.   TDBLookupCombo = class(TCustomEdit)
  30.   private
  31.     FCanvas: TControlCanvas;
  32.     FDropDownCount: Integer;
  33.     FDropDownWidth: Integer;
  34.     FTextMargin: Integer;
  35.     FFieldLink: TFieldDataLink;
  36.     FGrid: TPopupGrid;
  37.     FButton: TSpeedButton;
  38.     FBtnControl: TWinControl;
  39.     FStyle: TDBLookupComboStyle;
  40.     FOnDropDown: TNotifyEvent;
  41.     function GetDataField: string;
  42.     function GetDataSource: TDataSource;
  43.     function GetLookupSource: TDataSource;
  44.     function GetLookupDisplay: string;
  45.     function GetLookupField: string;
  46.     function GetReadOnly: Boolean;
  47.     function GetValue: string;
  48.     function GetDisplayValue: string;
  49.     function GetMinHeight: Integer;
  50.     function GetOptions: TDBLookupListOptions;
  51.     function CanEdit: Boolean;
  52.     function Editable: Boolean;
  53.     procedure SetValue(const NewValue: string);
  54.     procedure SetDisplayValue(const NewValue: string);
  55.     procedure DataChange(Sender: TObject);
  56.     procedure EditingChange(Sender: TObject);
  57.     procedure SetDataField(const Value: string);
  58.     procedure SetDataSource(Value: TDataSource);
  59.     procedure SetLookupSource(Value: TDataSource);
  60.     procedure SetLookupDisplay(const Value: string);
  61.     procedure SetLookupField(const Value: string);
  62.     procedure SetReadOnly(Value: Boolean);
  63.     procedure SetOptions(Value: TDBLookupListOptions);
  64.     procedure SetStyle(Value: TDBLookupComboStyle);
  65.     procedure UpdateData(Sender: TObject);
  66.     procedure FieldLinkActive(Sender: TObject);
  67.     procedure NonEditMouseDown(var Message: TWMLButtonDown);
  68.     procedure DoSelectAll;
  69.     procedure SetEditRect;
  70.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  71.     procedure WMCut(var Message: TMessage); message WM_CUT;
  72.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  73.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  74.     procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
  75.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  76.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  77.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  78.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  79.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  80.     procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
  81.     procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  82.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  83.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  84.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  85.   protected
  86.     procedure Notification(AComponent: TComponent;
  87.       Operation: TOperation); override;
  88.     procedure Change; override;
  89.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  90.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  91.     procedure KeyPress(var Key: Char); override;
  92.     procedure CreateParams(var Params: TCreateParams); override;
  93.     procedure CreateWnd; override;
  94.     procedure GridClick (Sender: TObject);
  95.     procedure Loaded; override;
  96.   public
  97.     constructor Create(AOwner: TComponent); override;
  98.     destructor Destroy; override;
  99.     procedure DropDown; dynamic;
  100.     procedure CloseUp; dynamic;
  101.     property Value: string read GetValue write SetValue;
  102.     property DisplayValue: string read GetDisplayValue write SetDisplayValue;
  103.   published
  104.     property DataField: string read GetDataField write SetDataField;
  105.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  106.     property LookupSource: TDataSource read GetLookupSource write SetLookupSource;
  107.     property LookupDisplay: string read GetLookupDisplay write SetLookupDisplay;
  108.     property LookupField: string read GetLookupField write SetLookupField;
  109.     property Options: TDBLookupListOptions read GetOptions write SetOptions default [];
  110.     property Style: TDBLookupComboStyle read FStyle write SetStyle default csDropDown;
  111.     property AutoSelect;
  112.     property Color;
  113.     property Ctl3D;
  114.     property DragCursor;
  115.     property DragMode;
  116.     property DropDownCount: Integer read FDropDownCount write FDropDownCount default 8;
  117.     property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
  118.     property Enabled;
  119.     property Font;
  120.     property ImeMode;
  121.     property ImeName;
  122.     property MaxLength;
  123.     property ParentColor;
  124.     property ParentCtl3D;
  125.     property ParentFont;
  126.     property ParentShowHint;
  127.     property PopupMenu;
  128.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  129.     property ShowHint;
  130.     property TabOrder;
  131.     property TabStop;
  132.     property Visible;
  133.     property OnChange;
  134.     property OnClick;
  135.     property OnDblClick;
  136.     property OnDragDrop;
  137.     property OnDragOver;
  138.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  139.     property OnEndDrag;
  140.     property OnEnter;
  141.     property OnExit;
  142.     property OnKeyDown;
  143.     property OnKeyPress;
  144.     property OnKeyUp;
  145.     property OnMouseDown;
  146.     property OnMouseMove;
  147.     property OnMouseUp;
  148.     property OnStartDrag;
  149.   end;
  150.  
  151. { TDBLookupList }
  152.  
  153.   TDBLookupList = class(TCustomDBGrid)
  154.   private
  155.     FFieldLink: TFieldDataLink;
  156.     FLookupDisplay: string;
  157.     FLookupField: string;
  158.     FDisplayFld: TField;
  159.     FValueFld: TField;
  160.     FValue: string;
  161.     FDisplayValue: string;
  162.     FHiliteRow: Integer;
  163.     FOptions: TDBLookupListOptions;
  164.     FTitleOffset: Integer;
  165.     FFoundValue: Boolean;
  166.     FInCellSelect: Boolean;
  167.     FOnListClick: TNotifyEvent;
  168.     function GetDataField: string;
  169.     function GetDataSource: TDataSource;
  170.     function GetLookupSource: TDataSource;
  171.     function GetReadOnly: Boolean;
  172.     procedure FieldLinkActive(Sender: TObject);
  173.     procedure DataChange(Sender: TObject);
  174.     procedure SetDataField(const Value: string);
  175.     procedure SetDataSource(Value: TDataSource);
  176.     procedure SetLookupSource(Value: TDataSource);
  177.     procedure SetLookupDisplay(const Value: string);
  178.     procedure SetLookupField(const Value: string);
  179.     procedure SetValue(const Value: string);
  180.     procedure SetDisplayValue(const Value: string);
  181.     procedure SetReadOnly(Value: Boolean);
  182.     procedure SetOptions(Value: TDBLookupListOptions);
  183.     procedure UpdateData(Sender: TObject);
  184.     procedure NewLayout;
  185.     procedure DoLookup;
  186.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  187.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  188.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  189.   protected
  190.     function HighlightCell(DataCol, DataRow: Integer; const Value: string;
  191.       AState: TGridDrawState): Boolean; override;
  192.     function CanGridAcceptKey(Key: Word; Shift: TShiftState): Boolean; override;
  193.     procedure DefineFieldMap; override;
  194.     procedure SetColumnAttributes; override;
  195.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  196.       X, Y: Integer); override;
  197.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  198.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  199.       X, Y: Integer); override;
  200.     function CanEdit: Boolean; virtual;
  201.     procedure InitFields(ShowError: Boolean);
  202.     procedure CreateWnd; override;
  203.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  204.     procedure KeyPress(var Key: Char); override;
  205.     procedure LinkActive(Value: Boolean); override;
  206.     procedure Paint; override;
  207.     procedure Scroll(Distance: Integer); override;
  208.     procedure ListClick; dynamic;
  209.     procedure Loaded; override;
  210.     procedure Notification(AComponent: TComponent;
  211.       Operation: TOperation); override;
  212.   public
  213.     constructor Create(AOwner: TComponent); override;
  214.     destructor Destroy; override;
  215.     property Value: string read FValue write SetValue;
  216.     property DisplayValue: string read FDisplayValue write SetDisplayValue;
  217.   published
  218.     property DataField: string read GetDataField write SetDataField;
  219.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  220.     property LookupSource: TDataSource read GetLookupSource write SetLookupSource;
  221.     property LookupDisplay: string read FLookupDisplay write SetLookupDisplay;
  222.     property LookupField: string read FLookupField write SetLookupField;
  223.     property Options: TDBLookupListOptions read FOptions write SetOptions default [];
  224.     property OnClick: TNotifyEvent read FOnListClick write FOnListClick;
  225.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  226.     property Align;
  227.     property BorderStyle;
  228.     property Color;
  229.     property Ctl3D;
  230.     property DragCursor;
  231.     property DragMode;
  232.     property Enabled;
  233.     property Font;
  234.     property ImeMode;
  235.     property ImeName;
  236.     property ParentColor;
  237.     property ParentCtl3D;
  238.     property ParentFont;
  239.     property ParentShowHint;
  240.     property PopupMenu;
  241.     property ShowHint;
  242.     property TabOrder;
  243.     property TabStop;
  244.     property Visible;
  245.     property OnDblClick;
  246.     property OnDragDrop;
  247.     property OnDragOver;
  248.     property OnEndDrag;
  249.     property OnEnter;
  250.     property OnExit;
  251.     property OnKeyDown;
  252.     property OnKeyPress;
  253.     property OnKeyUp;
  254.     property OnStartDrag;
  255.   end;
  256.  
  257. { TPopupGrid }
  258.  
  259.   TPopupGrid = class(TDBLookupList)
  260.   private
  261.     FCombo: TDBLookupCombo;
  262.     procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  263.   protected
  264.     procedure CreateParams(var Params: TCreateParams); override;
  265.     procedure CreateWnd; override;
  266.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  267.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  268.       X, Y: Integer); override;
  269.     function CanEdit: Boolean; override;
  270.     procedure LinkActive(Value: Boolean); override;
  271.   public
  272.     property RowCount;
  273.     constructor Create(AOwner: TComponent); override;
  274.   end;
  275.  
  276. { TComboButton }
  277.  
  278.   TComboButton = class(TSpeedButton)
  279.   protected
  280.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  281.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  282.       X, Y: Integer); override;
  283.   end;
  284.  
  285. implementation
  286.  
  287. uses DBConsts, BDEConst;
  288.  
  289. { TDBLookupCombo }
  290.  
  291. constructor TDBLookupCombo.Create(AOwner: TComponent);
  292. begin
  293.   inherited Create(AOwner);
  294.   AutoSize := False;
  295.   FFieldLink := TFieldDataLink.Create(Self);
  296.   FFieldLink.OnDataChange := DataChange;
  297.   FFieldLink.OnEditingChange := EditingChange;
  298.   FFieldLink.OnUpdateData := UpdateData;
  299.   FFieldLink.OnActiveChange := FieldLinkActive;
  300.   FBtnControl := TWinControl.Create(Self);
  301.   FBtnControl.Width := 17;
  302.   FBtnControl.Height := 17;
  303.   FBtnControl.Visible := True;
  304.   FBtnControl.Parent := Self;
  305.   FButton := TComboButton.Create(Self);
  306.   FButton.SetBounds(0, 0, FBtnControl.Width, FBtnControl.Height);
  307.   FButton.Glyph.Handle := LoadBitmap(0, PChar(32738));
  308.   FButton.Visible := True;
  309.   FButton.Parent := FBtnControl;
  310.   FGrid := TPopupGrid.Create(Self);
  311.   FGrid.FCombo := Self;
  312.   FGrid.Parent := Self;
  313.   FGrid.Visible := False;
  314.   FGrid.OnClick := GridClick;
  315.   Height := 25;
  316.   FDropDownCount := 8;
  317. end;
  318.  
  319. destructor TDBLookupCombo.Destroy;
  320. begin
  321.   FFieldLink.OnDataChange := nil;
  322.   FFieldLink.Free;
  323.   FFieldLink := nil;
  324.   inherited Destroy;
  325. end;
  326.  
  327. procedure TDBLookupCombo.Notification(AComponent: TComponent;
  328.   Operation: TOperation);
  329. begin
  330.   inherited Notification(AComponent, Operation);
  331.   if (Operation = opRemove) and (FFieldLink <> nil) then
  332.   begin
  333.     if (AComponent = DataSource) then DataSource := nil
  334.     else if (AComponent = LookupSource) then
  335.       LookupSource := nil;
  336.   end;
  337. end;
  338.  
  339. function TDBLookupCombo.Editable: Boolean;
  340. begin
  341.   Result := (FFieldLink.DataSource = nil) or
  342.     ((FGrid.FValueFld = FGrid.FDisplayFld) and (FStyle <> csDropDownList));
  343. end;
  344.  
  345. function TDBLookupCombo.CanEdit: Boolean;
  346. begin
  347.   Result := (FFieldLink.DataSource = nil) or
  348.     (FFieldLink.Editing and Editable);
  349. end;
  350.  
  351. procedure TDBLookupCombo.KeyDown(var Key: Word; Shift: TShiftState);
  352. begin
  353.   inherited KeyDown(Key, Shift);
  354.   if Key in [VK_BACK, VK_DELETE, VK_INSERT] then
  355.   begin
  356.     if Editable then
  357.       FFieldLink.Edit;
  358.     if not CanEdit then
  359.       Key := 0;
  360.   end
  361.   else if not Editable and (Key in [VK_HOME, VK_END, VK_LEFT, VK_RIGHT]) then
  362.     Key := 0;
  363.  
  364.   if (Key in [VK_UP, VK_DOWN, VK_NEXT, VK_PRIOR]) then
  365.   begin
  366.     if not FGrid.Visible then DropDown
  367.     else begin
  368.       FFieldLink.Edit;
  369.       if (FFieldLink.DataSource = nil) or FFieldLink.Editing then
  370.         FGrid.KeyDown(Key, Shift);
  371.     end;
  372.     Key := 0;
  373.   end;
  374. end;
  375.  
  376. procedure TDBLookupCombo.KeyPress(var Key: Char);
  377. begin
  378.   inherited KeyPress(Key);
  379.   if (Key in [#32..#255]) and (FFieldLink.Field <> nil) and
  380.     not FFieldLink.Field.IsValidChar(Key) and Editable then
  381.   begin
  382.     Key := #0;
  383.     MessageBeep(0)
  384.   end;
  385.  
  386.   case Key of
  387.     ^H, ^V, ^X, #32..#255:
  388.       begin
  389.         if Editable then FFieldLink.Edit;
  390.         if not CanEdit then Key := #0;
  391.       end;
  392.     char(VK_RETURN):
  393.       Key := #0;
  394.     char(VK_ESCAPE):
  395.       begin
  396.         if not FGrid.Visible then
  397.           FFieldLink.Reset
  398.         else CloseUp;
  399.         DoSelectAll;
  400.         Key := #0;
  401.       end;
  402.   end;
  403. end;
  404.  
  405. procedure TDBLookupCombo.Change;
  406. begin
  407.   if FFieldLink.Editing then FFieldLink.Modified;
  408.   inherited Change;
  409. end;
  410.  
  411. function TDBLookupCombo.GetDataSource: TDataSource;
  412. begin
  413.   Result := FFieldLink.DataSource;
  414. end;
  415.  
  416. procedure TDBLookupCombo.SetDataSource(Value: TDataSource);
  417. begin
  418.   if (Value <> nil) and (Value = LookupSource) then
  419.     raise EInvalidOperation.Create (SLookupSourceError);
  420.   if (Value <> nil) and (LookupSource <> nil) and (Value.DataSet <> nil) and
  421.     (Value.DataSet = LookupSource.DataSet) then
  422.     raise EInvalidOperation.Create(SLookupSourceError);
  423.   FFieldLink.DataSource := Value;
  424.   if Value <> nil then Value.FreeNotification(Self);
  425. end;
  426.  
  427. function TDBLookupCombo.GetLookupSource: TDataSource;
  428. begin
  429.   Result := FGrid.LookupSource;
  430. end;
  431.  
  432. procedure TDBLookupCombo.SetLookupSource(Value: TDataSource);
  433. begin
  434.   if (Value <> nil) and ((Value = DataSource) or
  435.     ((Value.DataSet <> nil) and (Value.DataSet = FFieldLink.DataSet))) then
  436.     raise EInvalidOperation.Create(SLookupSourceError);
  437.   FGrid.LookupSource := Value;
  438.   DataChange(Self);
  439.   if Value <> nil then Value.FreeNotification(Self);
  440. end;
  441.  
  442. procedure TDBLookupCombo.SetLookupDisplay(const Value: string);
  443. begin
  444.   FGrid.LookupDisplay := Value;
  445.   FGrid.InitFields(True);
  446.   SetValue('');
  447.   DataChange(Self);
  448. end;
  449.  
  450. function TDBLookupCombo.GetLookupDisplay: string;
  451. begin
  452.   Result := FGrid.LookupDisplay;
  453. end;
  454.  
  455. procedure TDBLookupCombo.SetLookupField(const Value: string);
  456. begin
  457.   FGrid.LookupField := Value;
  458.   FGrid.InitFields(True);
  459.   DataChange(Self);
  460. end;
  461.  
  462. function TDBLookupCombo.GetLookupField: string;
  463. begin
  464.   Result := FGrid.LookupField;
  465. end;
  466.  
  467. function TDBLookupCombo.GetDataField: string;
  468. begin
  469.   Result := FFieldLink.FieldName;
  470. end;
  471.  
  472. procedure TDBLookupCombo.SetDataField(const Value: string);
  473. begin
  474.   FFieldLink.FieldName := Value;
  475. end;
  476.  
  477. procedure TDBLookupCombo.DataChange(Sender: TObject);
  478. begin
  479.   if (FFieldLink.Field <> nil) and not (csLoading in ComponentState) then
  480.     Value := FFieldLink.Field.AsString
  481.   else Text := '';
  482. end;
  483.  
  484. function TDBLookupCombo.GetValue: String;
  485. begin
  486.   if Editable then
  487.     Result := Text else
  488.     Result := FGrid.Value;
  489. end;
  490.  
  491. function TDBLookupCombo.GetDisplayValue: String;
  492. begin
  493.   Result := Text;
  494. end;
  495.  
  496. procedure TDBLookupCombo.SetDisplayValue(const NewValue: String);
  497. begin
  498.   if FGrid.DisplayValue <> NewValue then
  499.     if FGrid.DataLink.Active then
  500.     begin
  501.       FGrid.DisplayValue := NewValue;
  502.       Text := FGrid.DisplayValue;
  503.     end;
  504. end;
  505.  
  506. procedure TDBLookupCombo.SetValue(const NewValue: String);
  507. begin
  508.   if FGrid.DataLink.Active and FFieldLink.Active and
  509.     ((DataSource = LookupSource) or
  510.     (DataSource.DataSet = LookupSource.DataSet)) then
  511.     raise EInvalidOperation.Create(SLookupSourceError);
  512.   if (FGrid.Value <> NewValue) or (Text <> NewValue) then
  513.     if FGrid.DataLink.Active then
  514.     begin
  515.       FGrid.Value := NewValue;
  516.       Text := FGrid.DisplayValue;
  517.     end;
  518. end;
  519.  
  520. function TDBLookupCombo.GetReadOnly: Boolean;
  521. begin
  522.   Result := FFieldLink.ReadOnly;
  523. end;
  524.  
  525. procedure TDBLookupCombo.SetReadOnly(Value: Boolean);
  526. begin
  527.   FFieldLink.ReadOnly := Value;
  528.   inherited ReadOnly := not CanEdit;
  529. end;
  530.  
  531. procedure TDBLookupCombo.EditingChange(Sender: TObject);
  532. begin
  533.   inherited ReadOnly := not CanEdit;
  534. end;
  535.  
  536. procedure TDBLookupCombo.UpdateData(Sender: TObject);
  537. begin
  538.   if FFieldLink.Field <> nil then
  539.     if Editable then
  540.       FFieldLink.Field.AsString := Text else
  541.       FFieldLink.Field.AsString := FGrid.Value;
  542. end;
  543.  
  544. procedure TDBLookupCombo.FieldLinkActive(Sender: TObject);
  545. begin
  546.   if FFieldLink.Active and FGrid.DataLink.Active then
  547.   begin
  548.     FGrid.SetValue('');
  549.     DataChange(Self)
  550.   end;
  551. end;
  552.  
  553. procedure TDBLookupCombo.WMPaste(var Message: TMessage);
  554. begin
  555.   if Editable then FFieldLink.Edit;
  556.   if CanEdit then inherited;
  557. end;
  558.  
  559. procedure TDBLookupCombo.WMCut(var Message: TMessage);
  560. begin
  561.   if Editable then FFieldLink.Edit;
  562.   if CanEdit then inherited;
  563. end;
  564.  
  565. procedure TDBLookupCombo.CreateParams(var Params: TCreateParams);
  566. begin
  567.   inherited CreateParams(Params);
  568.   Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN;
  569. end;
  570.  
  571. procedure TDBLookupCombo.CreateWnd;
  572. begin
  573.   inherited CreateWnd;
  574.   SetEditRect;
  575.   FGrid.HandleNeeded;
  576.   DataChange(Self);
  577. end;
  578.  
  579. procedure TDBLookupCombo.SetEditRect;
  580. var
  581.   Loc: TRect;
  582. begin
  583.   Loc.Bottom := ClientHeight + 1;  {+1 is workaround for windows paint bug}
  584.   Loc.Right := FBtnControl.Left - 2;
  585.   Loc.Top := 0;
  586.   Loc.Left := 0;
  587.   SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Loc));
  588. end;
  589.  
  590. procedure TDBLookupCombo.WMSize(var Message: TWMSize);
  591. var
  592.   MinHeight: Integer;
  593. begin
  594.   inherited;
  595.   if (csDesigning in ComponentState) then
  596.     FGrid.SetBounds(0, Height + 1, 10, 10);
  597.   MinHeight := GetMinHeight;
  598.   if Height < MinHeight then Height := MinHeight
  599.   else begin
  600.     if NewStyleControls then
  601.       FBtnControl.SetBounds(ClientWidth - FButton.Width, 0, FButton.Width, ClientHeight)
  602.     else
  603.       FBtnControl.SetBounds(ClientWidth - FButton.Width, 1, FButton.Width, ClientHeight - 1);
  604.     FButton.Height := FBtnControl.Height;
  605.     SetEditRect;
  606.   end;
  607. end;
  608.  
  609. function TDBLookupCombo.GetMinHeight: Integer;
  610. var
  611.   DC: HDC;
  612.   SaveFont: HFont;
  613.   I: Integer;
  614.   SysMetrics, Metrics: TTextMetric;
  615. begin
  616.   DC := GetDC(0);
  617.   GetTextMetrics(DC, SysMetrics);
  618.   SaveFont := SelectObject(DC, Font.Handle);
  619.   GetTextMetrics(DC, Metrics);
  620.   SelectObject(DC, SaveFont);
  621.   ReleaseDC(0, DC);
  622.   I := SysMetrics.tmHeight;
  623.   if I > Metrics.tmHeight then I := Metrics.tmHeight;
  624.   FTextMargin := I div 4;
  625.   Result := Metrics.tmHeight + FTextMargin + GetSystemMetrics(SM_CYBORDER) * 4 + 1;
  626. end;
  627.  
  628. procedure TDBLookupCombo.WMPaint(var Message: TWMPaint);
  629. var
  630.   PS: TPaintStruct;
  631.   ARect: TRect;
  632.   TextLeft, TextTop: Integer;
  633.   Focused: Boolean;
  634.   DC: HDC;
  635. const
  636.   Formats: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT,
  637.     DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX);
  638. begin
  639.   if Editable then
  640.   begin
  641.     inherited;
  642.     Exit;
  643.   end;
  644.  
  645.   if FCanvas = nil then
  646.   begin
  647.     FCanvas := TControlCanvas.Create;
  648.     FCanvas.Control := Self;
  649.   end;
  650.  
  651.   DC := Message.DC;
  652.   if DC = 0 then DC := BeginPaint(Handle, PS);
  653.   FCanvas.Handle := DC;
  654.   try
  655.     Focused := GetFocus = Handle;
  656.     FCanvas.Font := Font;
  657.     with FCanvas do
  658.     begin
  659.       ARect := ClientRect;
  660.       Brush.Color := clWindowFrame;
  661.       FrameRect(ARect);
  662.       InflateRect(ARect, -1, -1);
  663.       Brush.Style := bsSolid;
  664.       Brush.Color := Color;
  665.       FillRect (ARect);
  666.       TextTop := FTextMargin;
  667.       ARect.Left := ARect.Left + 2;
  668.       ARect.Right := FBtnControl.Left - 2;
  669.       TextLeft := FTextMargin;
  670.       if Focused then
  671.       begin
  672.         Brush.Color := clHighlight;
  673.         Font.Color := clHighlightText;
  674.         ARect.Top := ARect.Top + 2;
  675.         ARect.Bottom := ARect.Bottom - 2;
  676.       end;
  677.       ExtTextOut(FCanvas.Handle, TextLeft, TextTop, ETO_OPAQUE or ETO_CLIPPED, @ARect,
  678.         PChar(Text), Length(Text), nil);
  679.       if Focused then
  680.         DrawFocusRect(ARect);
  681.     end;
  682.   finally
  683.     FCanvas.Handle := 0;
  684.     if Message.DC = 0 then EndPaint(Handle, PS);
  685.   end;
  686. end;
  687.  
  688. procedure TDBLookupCombo.CMFontChanged(var Message: TMessage);
  689. begin
  690.   inherited;
  691.   GetMinHeight;
  692. end;
  693.  
  694. procedure TDBLookupCombo.CMEnabledChanged(var Message: TMessage);
  695. begin
  696.   inherited;
  697.   FButton.Enabled := Enabled;
  698. end;
  699.  
  700. procedure TDBLookupCombo.WMKillFocus(var Message: TWMKillFocus);
  701. begin
  702.   inherited;
  703.   CloseUp;
  704. end;
  705.  
  706. procedure TDBLookupCombo.CMCancelMode(var Message: TCMCancelMode);
  707. begin
  708.   with Message do
  709.     if (Sender <> Self) and (Sender <> FBtnControl) and
  710.       (Sender <> FButton) and (Sender <> FGrid) then CloseUp;
  711. end;
  712.  
  713. procedure TDBLookupCombo.CMHintShow(var Message: TMessage);
  714. begin
  715.   Message.Result := Integer(FGrid.Visible);
  716. end;
  717.  
  718. procedure TDBLookupCombo.DropDown;
  719. var
  720.   ItemCount: Integer;
  721.   P: TPoint;
  722.   Y: Integer;
  723.   GridWidth, GridHeight, BorderWidth: Integer;
  724.   SysBorderWidth, SysBorderHeight: Integer;
  725. begin
  726.   if not FGrid.Visible and (Width > 20) then
  727.   begin
  728.     if Assigned(FOnDropDown) then FOnDropDown(Self);
  729.     ItemCount := DropDownCount;
  730.     if ItemCount = 0 then ItemCount := 1;
  731.     SysBorderWidth := GetSystemMetrics(SM_CXBORDER);
  732.     SysBorderHeight := GetSystemMetrics(SM_CYBORDER);
  733.     P := ClientOrigin;
  734.     if NewStyleControls then
  735.     begin
  736.       Dec(P.X, 2 * SysBorderWidth);
  737.       Dec(P.Y, SysBorderHeight);
  738.     end;
  739.     if loRowLines in Options then
  740.       BorderWidth := 1 else
  741.       BorderWidth := 0;
  742.     GridHeight := (FGrid.DefaultRowHeight + BorderWidth) *
  743.       (ItemCount + FGrid.FTitleOffset) + 2;
  744.     FGrid.Height := GridHeight;
  745.     if ItemCount > FGrid.RowCount then
  746.     begin
  747.       ItemCount := FGrid.RowCount;
  748.       GridHeight := (FGrid.DefaultRowHeight + BorderWidth) *
  749.         (ItemCount + FGrid.FTitleOffset) + 4;
  750.     end;
  751.     if NewStyleControls then
  752.       Y := P.Y + ClientHeight + 3 * SysBorderHeight else
  753.       Y := P.Y + Height - 1;
  754.     if (Y + GridHeight) > Screen.Height then
  755.     begin
  756.       Y := P.Y - GridHeight + 1;
  757.       if Y < 0 then
  758.       begin
  759.         if NewStyleControls then
  760.           Y := P.Y + ClientHeight + 3 * SysBorderHeight else
  761.           Y := P.Y + Height - 1;
  762.       end;
  763.     end;
  764.     GridWidth := DropDownWidth;
  765.     if GridWidth = 0 then
  766.     begin
  767.       if NewStyleControls then
  768.         GridWidth := Width + 2 * SysBorderWidth else
  769.         GridWidth := Width - 4;
  770.     end;
  771.     if NewStyleControls then
  772.       SetWindowPos(FGrid.Handle, 0, P.X, Y, GridWidth, GridHeight, SWP_NOACTIVATE) else
  773.       SetWindowPos (FGrid.Handle, 0, P.X + Width - GridWidth, Y, GridWidth, GridHeight, SWP_NOACTIVATE);
  774.     if Length(LookupField) = 0 then
  775.       FGrid.DisplayValue := Text;
  776.     FGrid.Visible := True;
  777.     Windows.SetFocus(Handle);
  778.   end;
  779. end;
  780.  
  781. procedure TDBLookupCombo.CloseUp;
  782. begin
  783.   FGrid.Visible := False;
  784. end;
  785.  
  786. procedure TDBLookupCombo.GridClick(Sender: TObject);
  787. begin
  788.   FFieldLink.Edit;
  789.   if (FFieldLink.DataSource = nil) or FFieldLink.Editing then
  790.   begin
  791.     FFieldLink.Modified;
  792.     Text := FGrid.DisplayValue;
  793.   end;
  794. end;
  795.  
  796. procedure TDBLookupCombo.SetStyle(Value: TDBLookupComboStyle);
  797. begin
  798.   if FStyle <> Value then
  799.     FStyle := Value;
  800. end;
  801.  
  802. procedure TDBLookupCombo.WMLButtonDown(var Message: TWMLButtonDown);
  803. begin
  804.   if Editable then
  805.     inherited
  806.   else
  807.     NonEditMouseDown(Message);
  808. end;
  809.  
  810. procedure TDBLookupCombo.WMLButtonUp(var Message: TWMLButtonUp);
  811. begin
  812.   if not Editable then MouseCapture := False;
  813.   inherited;
  814. end;
  815.  
  816. procedure TDBLookupCombo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  817. begin
  818.   if Editable then
  819.     inherited
  820.   else
  821.     NonEditMouseDown(Message);
  822. end;
  823.  
  824. procedure TDBLookupCombo.NonEditMouseDown(var Message: TWMLButtonDown);
  825. var
  826.   CtrlState: TControlState;
  827. begin
  828.   SetFocus;
  829.   HideCaret (Handle);
  830.  
  831.   if FGrid.Visible then CloseUp
  832.   else DropDown;
  833.  
  834.   MouseCapture := True;
  835.   if csClickEvents in ControlStyle then
  836.   begin
  837.     CtrlState := ControlState;
  838.     Include(CtrlState, csClicked);
  839.     ControlState := CtrlState;
  840.   end;
  841.   with Message do
  842.     MouseDown(mbLeft, KeysToShiftState(Keys), XPos, YPos);
  843. end;
  844.  
  845. procedure MouseDragToGrid(Ctrl: TControl; Grid: TPopupGrid; X, Y: Integer);
  846. var
  847.   pt, clientPt: TPoint;
  848. begin
  849.   if Grid.Visible then
  850.   begin
  851.     pt.X := X;
  852.     pt.Y := Y;
  853.     pt := Ctrl.ClientToScreen (pt);
  854.     clientPt := Grid.ClientOrigin;
  855.     if (pt.X >= clientPt.X) and (pt.Y >= clientPt.Y) and
  856.        (pt.X <= clientPt.X + Grid.ClientWidth) and
  857.        (pt.Y <= clientPt.Y + Grid.ClientHeight) then
  858.     begin
  859.       Ctrl.Perform(WM_LBUTTONUP, 0, MakeLong (X, Y));
  860.       pt := Grid.ScreenToClient(pt);
  861.       Grid.Perform(WM_LBUTTONDOWN, 0, MakeLong (pt.x, pt.y));
  862.     end;
  863.   end;
  864. end;
  865.  
  866. procedure TDBLookupCombo.MouseMove(Shift: TShiftState; X, Y: Integer);
  867. begin
  868.   inherited MouseMove(Shift, X, Y);
  869.   if (ssLeft in Shift) and not Editable and (GetCapture = Handle) then
  870.     MouseDragToGrid(Self, FGrid, X, Y);
  871. end;
  872.  
  873. procedure TDBLookupCombo.WMSetFocus(var Message: TWMSetFocus);
  874. begin
  875.   inherited;
  876.   if not Editable then HideCaret(Handle);
  877. end;
  878.  
  879. procedure TDBLookupCombo.CMExit(var Message: TCMExit);
  880. begin
  881.   try
  882.     FFieldLink.UpdateRecord;
  883.   except
  884.     DoSelectAll;
  885.     SetFocus;
  886.     raise;
  887.   end;
  888.   inherited;
  889.   if not Editable then Invalidate;
  890. end;
  891.  
  892. procedure TDBLookupCombo.CMEnter(var Message: TCMGotFocus);
  893. begin
  894.   if AutoSelect and not (csLButtonDown in ControlState) then DoSelectAll;
  895.   inherited;
  896.   if not Editable then Invalidate;
  897. end;
  898.  
  899. procedure TDBLookupCombo.DoSelectAll;
  900. begin
  901.   if Editable then SelectAll;
  902. end;
  903.  
  904. procedure TDBLookupCombo.SetOptions(Value: TDBLookupListOptions);
  905. begin
  906.   FGrid.Options := Value;
  907. end;
  908.  
  909. function TDBLookupCombo.GetOptions: TDBLookupListOptions;
  910. begin
  911.   Result := FGrid.Options;
  912. end;
  913.  
  914. procedure TDBLookupCombo.Loaded;
  915. begin
  916.   inherited Loaded;
  917.   DataChange(Self);
  918. end;
  919.  
  920. { TLookupList }
  921.  
  922. constructor TDBLookupList.Create(AOwner: TComponent);
  923. begin
  924.   inherited Create(AOwner);
  925.   FFieldLink := TFieldDataLink.Create(Self);
  926.   FFieldLink.OnDataChange := DataChange;
  927.   FFieldLink.OnUpdateData := UpdateData;
  928.   FFieldLink.OnActiveChange := FieldLinkActive;
  929.   FTitleOffset := 0;
  930.   FUpdateFields := False;
  931.   FHiliteRow := -1;
  932.   inherited Options := [dgRowSelect];
  933.   FixedCols := 0;
  934.   FixedRows := 0;
  935.   Width := 121;
  936.   Height := 97;
  937. end;
  938.  
  939. destructor TDBLookupList.Destroy;
  940. begin
  941.   FFieldLink.OnDataChange := nil;
  942.   FFieldLink.Free;
  943.   FFieldLink := nil;
  944.   inherited Destroy;
  945. end;
  946.  
  947. procedure TDBLookupList.CreateWnd;
  948. begin
  949.   inherited CreateWnd;
  950.   DataChange(Self);
  951. end;
  952.  
  953. procedure TDBLookupList.Notification(AComponent: TComponent;
  954.   Operation: TOperation);
  955. begin
  956.   inherited Notification(AComponent, Operation);
  957.   if (Operation = opRemove) and (FFieldLink <> nil) and
  958.     (AComponent = DataSource) then
  959.     DataSource := nil;
  960. end;
  961.  
  962. function TDBLookupList.GetDataSource: TDataSource;
  963. begin
  964.   Result := FFieldLink.DataSource;
  965. end;
  966.  
  967. procedure TDBLookupList.SetDataSource(Value: TDataSource);
  968. begin
  969.   if (Value <> nil) and ((Value = LookupSource) or ((Value.DataSet <> nil)
  970.     and (Value.DataSet = DataLink.DataSet))) then
  971.     raise EInvalidOperation.Create(SLookupSourceError);
  972.   FFieldLink.DataSource := Value;
  973.   if Value <> nil then Value.FreeNotification(Self);
  974. end;
  975.  
  976. function TDBLookupList.GetLookupSource: TDataSource;
  977. begin
  978.   Result := inherited DataSource;
  979. end;
  980.  
  981. procedure TDBLookupList.NewLayout;
  982. begin
  983.   InitFields(True);
  984.   LayoutChanged;
  985.   FValue := '';
  986.   DataChange(Self);
  987. end;
  988.  
  989. procedure TDBLookupList.SetLookupSource(Value: TDataSource);
  990. begin
  991.   if (Value <> nil) and ((Value = DataSource) or
  992.     ((Value.DataSet <> nil) and (Value.DataSet = FFieldLink.DataSet))) then
  993.     raise EInvalidOperation.Create(SLookupSourceError);
  994.   if (Value <> nil) and (Value.DataSet <> nil) and
  995.     not (Value.DataSet.InheritsFrom(TTable)) then
  996.     raise EInvalidOperation.Create(SLookupTableError);
  997.   inherited DataSource := Value;
  998.   NewLayout;
  999. end;
  1000.  
  1001. procedure TDBLookupList.SetLookupDisplay(const Value: string);
  1002. begin
  1003.   if Value <> LookupDisplay then
  1004.   begin
  1005.     FLookupDisplay := Value;
  1006.     NewLayout;
  1007.   end;
  1008. end;
  1009.  
  1010. procedure TDBLookupList.SetLookupField(const Value: string);
  1011. begin
  1012.   if Value <> LookupField then
  1013.   begin
  1014.     FLookupField := Value;
  1015.     NewLayout;
  1016.   end;
  1017. end;
  1018.  
  1019. procedure TDBLookupList.SetValue(const Value: string);
  1020. begin
  1021.   if DataLink.Active and FFieldLink.Active and
  1022.     ((DataSource = LookupSource) or
  1023.     (DataSource.DataSet = LookupSource.DataSet)) then
  1024.     raise EInvalidOperation.Create(SLookupSourceError);
  1025.  
  1026.   if (FValue <> Value) or (Row = FTitleOffset) then
  1027.     if DataLink.Active and (FValueFld <> nil) then
  1028.     begin
  1029.       FValue := Value;
  1030.       FHiliteRow := -1;
  1031.       DoLookup;
  1032.       if FFoundValue and (FValueFld <> FDisplayFld) then
  1033.         FDisplayValue := FDisplayFld.AsString
  1034.       else if (FValueFld = FDisplayFld) then FDisplayValue := FValue
  1035.       else FDisplayValue := '';
  1036.     end;
  1037. end;
  1038.  
  1039. procedure TDBLookupList.SetDisplayValue(const Value: string);
  1040. begin
  1041.   if (FDisplayValue <> Value) or (Row = FTitleOffset) then
  1042.   begin
  1043.     FFoundValue := False;
  1044.     if DataLink.Active and (FDisplayFld <> nil) then
  1045.     begin
  1046.       FHiliteRow := -1;
  1047.       FFoundValue := False;
  1048.       if inherited DataSource.DataSet is TTable then
  1049.         with TTable(inherited DataSource.DataSet) do
  1050.         begin
  1051.           SetKey;
  1052.           FDisplayFld.AsString := Value;
  1053.           FFoundValue := GotoKey;
  1054.         end;
  1055.       FDisplayValue := Value;
  1056.       if FValueFld = FDisplayFld then FValue := FDisplayValue
  1057.       else if not FFoundValue then
  1058.       begin
  1059.         FDisplayValue := '';
  1060.         FValue := '';
  1061.       end
  1062.       else FValue := FValueFld.AsString;
  1063.     end;
  1064.   end;
  1065. end;
  1066.  
  1067. procedure TDBLookupList.DoLookup;
  1068. begin
  1069.   FFoundValue := False;
  1070.   if not HandleAllocated then Exit;
  1071.   if Value = '' then Exit;
  1072.   if inherited DataSource.DataSet is TTable then
  1073.     with TTable(inherited DataSource.DataSet) do
  1074.     begin
  1075.       if (IndexFieldCount > 0) then
  1076.       begin
  1077.         if AnsiCompareText(IndexFields[0].FieldName, LookupField) <> 0 then
  1078.           raise EInvalidOperation.Create(Format(SLookupIndexError, [LookupField]));
  1079.       end;
  1080.       if State = dsSetKey then Exit;
  1081.       SetKey;
  1082.       FValueFld.AsString := Value;
  1083.       FFoundValue := GotoKey;
  1084.       if not FFoundValue then First;
  1085.     end;
  1086. end;
  1087.  
  1088. function TDBLookupList.GetDataField: string;
  1089. begin
  1090.   Result := FFieldLink.FieldName;
  1091. end;
  1092.  
  1093. procedure TDBLookupList.SetDataField(const Value: string);
  1094. begin
  1095.   FFieldLink.FieldName := Value;
  1096. end;
  1097.  
  1098. function TDBLookupList.GetReadOnly: Boolean;
  1099. begin
  1100.   Result := FFieldLink.ReadOnly;
  1101. end;
  1102.  
  1103. function TDBLookupList.CanEdit: Boolean;
  1104. begin
  1105.   Result := (FFieldLink.DataSource = nil) or FFieldLink.Editing;
  1106. end;
  1107.  
  1108. procedure TDBLookupList.SetReadOnly(Value: Boolean);
  1109. begin
  1110.   FFieldLink.ReadOnly := Value;
  1111. end;
  1112.  
  1113. procedure TDBLookupList.DataChange(Sender: TObject);
  1114. begin
  1115.   if (FFieldLink.Field <> nil) and not (csLoading in ComponentState) then
  1116.     Value := FFieldLink.Field.AsString else
  1117.     Value := '';
  1118. end;
  1119.  
  1120. procedure TDBLookupList.UpdateData(Sender: TObject);
  1121. begin
  1122.   if FFieldLink.Field <> nil then
  1123.     FFieldLink.Field.AsString := Value;
  1124. end;
  1125.  
  1126. procedure TDBLookupList.InitFields(ShowError: Boolean);
  1127. var
  1128.   Pos: Integer;
  1129. begin
  1130.   FDisplayFld := nil;
  1131.   FValueFld := nil;
  1132.   if not DataLink.Active or (Length(LookupField) = 0) then Exit;
  1133.   with Datalink.DataSet do
  1134.   begin
  1135.     FValueFld := FindField(LookupField);
  1136.     if (FValueFld = nil) and ShowError then
  1137.       raise EInvalidOperation.Create(Format(SFieldNotFound, [Self.Name, LookupField]))
  1138.     else if FValueFld <> nil then
  1139.     begin
  1140.       if Length(LookupDisplay) > 0 then
  1141.       begin
  1142.         Pos := 1;
  1143.         FDisplayFld := FindField(ExtractFieldName(LookupDisplay, Pos));
  1144.         if (FDisplayFld = nil) and ShowError then
  1145.         begin
  1146.           Pos := 1;
  1147.           raise EInvalidOperation.Create(Format(SFieldNotFound,
  1148.             [Self.Name, ExtractFieldName(LookupDisplay, Pos)]));
  1149.         end;
  1150.       end;
  1151.       if FDisplayFld = nil then FDisplayFld := FValueFld;
  1152.     end;
  1153.   end;
  1154. end;
  1155.  
  1156. procedure TDBLookupList.DefineFieldMap;
  1157. var
  1158.   Pos: Integer;
  1159. begin
  1160.   InitFields(False);
  1161.   if FValueFld <> nil then
  1162.   begin
  1163.     if Length(LookupDisplay) = 0 then
  1164.       Datalink.AddMapping (FValueFld.FieldName)
  1165.     else begin
  1166.       Pos := 1;
  1167.       while Pos <= Length(LookupDisplay) do
  1168.         Datalink.AddMapping(ExtractFieldName(LookupDisplay, Pos));
  1169.     end;
  1170.   end;
  1171. end;
  1172.  
  1173. procedure TDBLookupList.SetColumnAttributes;
  1174. var
  1175.   I: Integer;
  1176.   TotalWidth, BorderWidth: Integer;
  1177. begin
  1178.   inherited SetColumnAttributes;
  1179.   if FieldCount > 0 then
  1180.   begin
  1181.     BorderWidth := 0;
  1182.     if loColLines in FOptions then BorderWidth := 1;
  1183.     TotalWidth := 0;
  1184.     for I := 0 to ColCount - 2 do
  1185.       TotalWidth := TotalWidth + ColWidths[I] + BorderWidth;
  1186.     if (ColCount = 1) or (TotalWidth < (ClientWidth - 15)) then
  1187.       ColWidths[ColCount-1] := ClientWidth - TotalWidth;
  1188.   end;
  1189. end;
  1190.  
  1191. procedure TDBLookupList.WMSize(var Message: TWMSize);
  1192. begin
  1193.   inherited;
  1194.   SetColumnAttributes;
  1195. end;
  1196.  
  1197. function TDBLookupList.CanGridAcceptKey(Key: Word; Shift: TShiftState): Boolean;
  1198. var
  1199.   MyOnKeyDown: TKeyEvent;
  1200. begin
  1201.   Result := True;
  1202.   if Key = VK_INSERT then Result := False
  1203.   else if Key in [VK_UP, VK_DOWN, VK_NEXT, VK_RIGHT, VK_LEFT, VK_PRIOR,
  1204.     VK_HOME, VK_END] then
  1205.   begin
  1206.     FFieldLink.Edit;
  1207.     if (Key in [VK_UP, VK_DOWN, VK_RIGHT, VK_LEFT]) and not CanEdit then
  1208.       Result := False
  1209.     else if (inherited DataSource <> nil) and
  1210.       (inherited DataSource.State <> dsInactive) then
  1211.     begin
  1212.       if (FHiliteRow >= 0) and (FHiliteRow <> DataLink.ActiveRecord) then
  1213.       begin
  1214.         Row := FHiliteRow;
  1215.         Datalink.ActiveRecord := FHiliteRow;
  1216.       end
  1217.       else if (FHiliteRow < 0) then
  1218.       begin
  1219.         if FFoundValue then
  1220.           DoLookup
  1221.         else begin
  1222.           DataLink.DataSource.DataSet.First;
  1223.           Row := FTitleOffset;
  1224.           Key := 0;
  1225.           MyOnKeyDown := OnKeyDown;
  1226.           if Assigned(MyOnKeyDown) then MyOnKeyDown(Self, Key, Shift);
  1227.           InvalidateRow (FTitleOffset);
  1228.           ListClick;
  1229.           Result := False;
  1230.         end;
  1231.       end;
  1232.     end;
  1233.   end;
  1234. end;
  1235.  
  1236. procedure TDBLookupList.KeyDown(var Key: Word; Shift: TShiftState);
  1237. begin
  1238.   try
  1239.     FInCellSelect := True;
  1240.     inherited KeyDown (Key, Shift);
  1241.   finally
  1242.     FInCellSelect := False;
  1243.   end;
  1244.   if (Key in [VK_UP, VK_DOWN, VK_NEXT, VK_PRIOR, VK_HOME, VK_END]) and
  1245.     CanEdit then ListClick;
  1246. end;
  1247.  
  1248. procedure TDBLookupList.KeyPress(var Key: Char);
  1249. begin
  1250.   inherited KeyPress (Key);
  1251.   case Key of
  1252.     #32..#255:
  1253.       DataLink.Edit;
  1254.     Char (VK_ESCAPE):
  1255.       begin
  1256.         FFieldLink.Reset;
  1257.         Key := #0;
  1258.       end;
  1259.   end;
  1260. end;
  1261.  
  1262. procedure TDBLookupList.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1263.   X, Y: Integer);
  1264. var
  1265.   CellHit: TGridCoord;
  1266.   MyOnMouseDown: TMouseEvent;
  1267. begin
  1268.   if not (csDesigning in ComponentState) and CanFocus and TabStop then
  1269.   begin
  1270.     SetFocus;
  1271.     if ValidParentForm(Self).ActiveControl <> Self then
  1272.     begin
  1273.       MouseCapture := False;
  1274.       Exit;
  1275.     end;
  1276.   end;
  1277.   if ssDouble in Shift then
  1278.   begin
  1279.     DblClick;
  1280.     Exit;
  1281.   end;
  1282.   if (Button = mbLeft) and (DataLink.DataSource <> nil) and
  1283.     (FDisplayFld <> nil) then
  1284.   begin
  1285.     CellHit := MouseCoord(X, Y);
  1286.     if (CellHit.Y >= FTitleOffset) then
  1287.     begin
  1288.       FFieldLink.Edit;
  1289.       FGridState := gsSelecting;
  1290.       SetTimer(Handle, 1, 60, nil);
  1291.       if (CellHit.Y <> (FHiliteRow + FTitleOffset)) then
  1292.       begin
  1293.         InvalidateRow(FHiliteRow + FTitleOffset);
  1294.         InvalidateRow(CellHit.Y);
  1295.       end;
  1296.       Row := CellHit.Y;
  1297.       Datalink.ActiveRecord := Row - FTitleOffset;
  1298.     end;
  1299.   end;
  1300.   MyOnMouseDown := OnMouseDown;
  1301.   if Assigned(MyOnMouseDown) then MyOnMouseDown(Self, Button, Shift, X, Y);
  1302. end;
  1303.  
  1304. procedure TDBLookupList.MouseMove(Shift: TShiftState; X, Y: Integer);
  1305. begin
  1306.   inherited MouseMove(Shift, X, Y);
  1307.   if (FGridState = gsSelecting) and (Row >= FTitleOffset) then
  1308.     Datalink.ActiveRecord := Row - FTitleOffset;
  1309. end;
  1310.  
  1311. procedure TDBLookupList.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1312.   X, Y: Integer);
  1313. var
  1314.   OldState: TGridState;
  1315. begin
  1316.   OldState := FGridState;
  1317.   inherited MouseUp(Button, Shift, X, Y);
  1318.   if OldState = gsSelecting then
  1319.   begin
  1320.     if Row >= FTitleOffset then
  1321.       Datalink.ActiveRecord := Row - FTitleOffset;
  1322.     ListClick;
  1323.   end;
  1324. end;
  1325.  
  1326. procedure TDBLookupList.ListClick;
  1327. begin
  1328.   if CanEdit and (FDisplayFld <> nil) then
  1329.   begin
  1330.     if FFieldLink.Editing then FFieldLink.Modified;
  1331.     FDisplayValue := FDisplayFld.AsString;
  1332.     if (FValueFld <> FDisplayFld) then
  1333.       FValue := FValueFld.AsString
  1334.     else FValue := FDisplayValue;
  1335.   end;
  1336.   if Assigned(FOnListClick) then FOnListClick(Self);
  1337. end;
  1338.  
  1339. function TDBLookupList.HighlightCell(DataCol, DataRow: Integer;
  1340.   const Value: string; AState: TGridDrawState): Boolean;
  1341. var
  1342.   OldActive: Integer;
  1343. begin
  1344.   Result := False;
  1345.   if not DataLink.Active or (FValueFld = nil) then Exit;
  1346.   if CanEdit and ((FGridState = gsSelecting) or FInCellSelect) then
  1347.   begin
  1348.     if Row = (DataRow + FTitleOffset) then
  1349.     begin
  1350.       Result := True;
  1351.       FHiliteRow := DataRow;
  1352.     end;
  1353.   end
  1354.   else begin
  1355.     OldActive := DataLink.ActiveRecord;
  1356.     try
  1357.       DataLink.ActiveRecord := DataRow;
  1358.       if FValue = FValueFld.AsString then
  1359.       begin
  1360.         Result := True;
  1361.         FHiliteRow := DataRow;
  1362.       end;
  1363.     finally
  1364.       DataLink.ActiveRecord := OldActive;
  1365.     end;
  1366.   end;
  1367. end;
  1368.  
  1369. procedure TDBLookupList.Paint;
  1370. begin
  1371.   FHiliteRow := -1;
  1372.   inherited Paint;
  1373.   if Focused and (FHiliteRow <> -1) then
  1374.     Canvas.DrawFocusRect(BoxRect(0, FHiliteRow, MaxInt, FHiliteRow));
  1375. end;
  1376.  
  1377. procedure TDBLookupList.Scroll(Distance: Integer);
  1378. begin
  1379.   if FHiliteRow >= 0 then
  1380.   begin
  1381.     FHiliteRow := FHiliteRow - Distance;
  1382.     if FHiliteRow >= VisibleRowCount then FHiliteRow := -1;
  1383.   end;
  1384.   inherited Scroll(Distance);
  1385. end;
  1386.  
  1387. procedure TDBLookupList.LinkActive(Value: Boolean);
  1388. begin
  1389.   inherited LinkActive(Value);
  1390.   if DataLink.Active then
  1391.   begin
  1392.     if not (LookupSource.DataSet.InheritsFrom(TTable)) then
  1393.       raise EInvalidOperation.Create(SLookupTableError);
  1394.     SetValue('');
  1395.     DataChange(Self);
  1396.   end;
  1397. end;
  1398.  
  1399. procedure TDBLookupList.FieldLinkActive(Sender: TObject);
  1400. begin
  1401.   if FFieldLink.Active and DataLink.Active then DataChange(Self);
  1402. end;
  1403.  
  1404. procedure TDBLookupList.CMEnter(var Message: TCMEnter);
  1405. begin
  1406.   inherited;
  1407.   if FHiliteRow <> -1 then InvalidateRow(FHiliteRow);
  1408. end;
  1409.  
  1410. procedure TDBLookupList.CMExit(var Message: TCMExit);
  1411. begin
  1412.   try
  1413.     FFieldLink.UpdateRecord;
  1414.   except
  1415.     SetFocus;
  1416.     raise;
  1417.   end;
  1418.   inherited;
  1419.   if FHiliteRow <> -1 then InvalidateRow(FHiliteRow);
  1420. end;
  1421.  
  1422. procedure TDBLookupList.SetOptions(Value: TDBLookupListOptions);
  1423. var
  1424.   NewGridOptions: TDBGridOptions;
  1425. begin
  1426.   if FOptions <> Value then
  1427.   begin
  1428.     FOptions := Value;
  1429.     FTitleOffset := 0;
  1430.     NewGridOptions := [dgRowSelect];
  1431.     if loColLines in Value then
  1432.       NewGridOptions := NewGridOptions + [dgColLines];
  1433.     if loRowLines in Value then
  1434.       NewGridOptions := NewGridOptions + [dgRowLines];
  1435.     if loTitles in Value then
  1436.     begin
  1437.       FTitleOffset := 1;
  1438.       NewGridOptions := NewGridOptions + [dgTitles];
  1439.     end;
  1440.     inherited Options := NewGridOptions;
  1441.   end;
  1442. end;
  1443.  
  1444. procedure TDBLookupList.Loaded;
  1445. begin
  1446.   inherited Loaded;
  1447.   DataChange(Self);
  1448. end;
  1449.  
  1450. { TPopupGrid }
  1451.  
  1452. constructor TPopupGrid.Create(AOwner: TComponent);
  1453. begin
  1454.   inherited Create(AOwner);
  1455.   FAcquireFocus := False;
  1456.   TabStop := False;
  1457. end;
  1458.  
  1459. procedure TPopupGrid.CreateParams(var Params: TCreateParams);
  1460. begin
  1461.   inherited CreateParams(Params);
  1462.   Params.WindowClass.Style := CS_SAVEBITS;
  1463. end;
  1464.  
  1465. procedure TPopupGrid.CreateWnd;
  1466. begin
  1467.   inherited CreateWnd;
  1468.   if not (csDesigning in ComponentState) then
  1469.     Windows.SetParent(Handle, 0);
  1470.   CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);
  1471.   FCombo.DataChange(Self);
  1472. end;
  1473.  
  1474. procedure TPopupGrid.WMLButtonUp(var Message: TWMLButtonUp);
  1475. begin
  1476.   inherited;
  1477.   FCombo.CloseUp;
  1478. end;
  1479.  
  1480. function TPopupGrid.CanEdit: Boolean;
  1481. begin
  1482.   Result := (FCombo.FFieldLink.DataSource = nil) or FCombo.FFieldLink.Editing;
  1483. end;
  1484.  
  1485. procedure TPopupGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1486.   X, Y: Integer);
  1487. begin
  1488.   FCombo.FFieldLink.Edit;
  1489.   inherited MouseDown(Button, Shift, X, Y);
  1490. end;
  1491.  
  1492. procedure TPopupGrid.LinkActive(Value: Boolean);
  1493. begin
  1494.   if Parent = nil then Exit;
  1495.   inherited LinkActive (Value);
  1496.   if DataLink.Active then
  1497.   begin
  1498.     if FValueFld = nil then InitFields(True);
  1499.     SetValue ('');
  1500.     FCombo.DataChange(Self);
  1501.   end;
  1502. end;
  1503.  
  1504. procedure TPopupGrid.CMHintShow(var Message: TMessage);
  1505. begin
  1506.   Message.Result := 1;
  1507. end;
  1508.  
  1509. { TComboButton }
  1510.  
  1511. procedure TComboButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1512.   X, Y: Integer);
  1513. begin
  1514.   with TDBLookupCombo (Parent.Parent) do
  1515.     if not FGrid.Visible then
  1516.       if (Handle <> GetFocus) and CanFocus then
  1517.       begin
  1518.         SetFocus;
  1519.         if GetFocus <> Handle then Exit;
  1520.       end;
  1521.   inherited MouseDown (Button, Shift, X, Y);
  1522.   with TDBLookupCombo (Parent.Parent) do
  1523.     if FGrid.Visible then CloseUp
  1524.     else DropDown;
  1525. end;
  1526.  
  1527. procedure TComboButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  1528. begin
  1529.   inherited MouseMove (Shift, X, Y);
  1530.   if (ssLeft in Shift) and (GetCapture = Parent.Handle) then
  1531.     MouseDragToGrid(Self, TDBLookupCombo(Parent.Parent).FGrid, X, Y);
  1532. end;
  1533.  
  1534. end.
  1535.